home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / zuoik.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  9.4 KB  |  266 lines

  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((zeror 0.0) (zeroi 0.0) (aic 1.2655121234846454))
  12.   (declare (type double-float aic zeroi zeror))
  13.   (defun zuoik (zr zi fnu kode ikflg n yr yi nuf tol elim alim)
  14.     (declare (type (simple-array double-float (*)) yr yi)
  15.              (type f2cl-lib:integer4 kode ikflg n nuf)
  16.              (type double-float zr zi fnu tol elim alim))
  17.     (prog ((cwrkr (make-array 16 :element-type 'double-float))
  18.            (cwrki (make-array 16 :element-type 'double-float)) (i 0) (idum 0)
  19.            (iform 0) (init 0) (nn 0) (nw 0) (aarg 0.0) (aphi 0.0) (argi 0.0)
  20.            (argr 0.0) (asumi 0.0) (asumr 0.0) (ascle 0.0) (ax 0.0) (ay 0.0)
  21.            (bsumi 0.0) (bsumr 0.0) (czi 0.0) (czr 0.0) (fnn 0.0) (gnn 0.0)
  22.            (gnu 0.0) (phii 0.0) (phir 0.0) (rcz 0.0) (str 0.0) (sti 0.0)
  23.            (sumi 0.0) (sumr 0.0) (zbi 0.0) (zbr 0.0) (zeta1i 0.0) (zeta1r 0.0)
  24.            (zeta2i 0.0) (zeta2r 0.0) (zni 0.0) (znr 0.0) (zri 0.0) (zrr 0.0))
  25.       (declare (type (simple-array double-float (16)) cwrkr cwrki)
  26.                (type double-float zrr zri znr zni zeta2r zeta2i zeta1r zeta1i
  27.                 zbr zbi sumr sumi sti str rcz phir phii gnu gnn fnn czr czi
  28.                 bsumr bsumi ay ax ascle asumr asumi argr argi aphi aarg)
  29.                (type f2cl-lib:integer4 nw nn init iform idum i))
  30.       (setf nuf 0)
  31.       (setf nn n)
  32.       (setf zrr zr)
  33.       (setf zri zi)
  34.       (if (>= zr 0.0) (go label10))
  35.       (setf zrr (- zr))
  36.       (setf zri (- zi))
  37.      label10
  38.       (setf zbr zrr)
  39.       (setf zbi zri)
  40.       (setf ax (* (abs zr) 1.7321))
  41.       (setf ay (coerce (abs zi) 'double-float))
  42.       (setf iform 1)
  43.       (if (> ay ax) (setf iform 2))
  44.       (setf gnu (max fnu 1.0))
  45.       (if (= ikflg 1) (go label20))
  46.       (setf fnn (coerce (the f2cl-lib:integer4 nn) 'double-float))
  47.       (setf gnn (- (+ fnu fnn) 1.0))
  48.       (setf gnu (max gnn fnn))
  49.      label20
  50.       (if (= iform 2) (go label30))
  51.       (setf init 0)
  52.       (multiple-value-bind
  53.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  54.            var-11 var-12 var-13 var-14 var-15 var-16)
  55.           (zunik zrr zri gnu ikflg 1 tol init phir phii zeta1r zeta1i zeta2r
  56.            zeta2i sumr sumi cwrkr cwrki)
  57.         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
  58.         (setf init var-6)
  59.         (setf phir var-7)
  60.         (setf phii var-8)
  61.         (setf zeta1r var-9)
  62.         (setf zeta1i var-10)
  63.         (setf zeta2r var-11)
  64.         (setf zeta2i var-12)
  65.         (setf sumr var-13)
  66.         (setf sumi var-14))
  67.       (setf czr (- zeta2r zeta1r))
  68.       (setf czi (- zeta2i zeta1i))
  69.       (go label50)
  70.      label30
  71.       (setf znr zri)
  72.       (setf zni (- zrr))
  73.       (if (> zi 0.0) (go label40))
  74.       (setf znr (- znr))
  75.      label40
  76.       (multiple-value-bind
  77.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  78.            var-11 var-12 var-13 var-14 var-15 var-16)
  79.           (zunhj znr zni gnu 1 tol phir phii argr argi zeta1r zeta1i zeta2r
  80.            zeta2i asumr asumi bsumr bsumi)
  81.         (declare (ignore var-0 var-1 var-2 var-3 var-4))
  82.         (setf phir var-5)
  83.         (setf phii var-6)
  84.         (setf argr var-7)
  85.         (setf argi var-8)
  86.         (setf zeta1r var-9)
  87.         (setf zeta1i var-10)
  88.         (setf zeta2r var-11)
  89.         (setf zeta2i var-12)
  90.         (setf asumr var-13)
  91.         (setf asumi var-14)
  92.         (setf bsumr var-15)
  93.         (setf bsumi var-16))
  94.       (setf czr (- zeta2r zeta1r))
  95.       (setf czi (- zeta2i zeta1i))
  96.       (setf aarg (zabs argr argi))
  97.      label50
  98.       (if (= kode 1) (go label60))
  99.       (setf czr (- czr zbr))
  100.       (setf czi (- czi zbi))
  101.      label60
  102.       (if (= ikflg 1) (go label70))
  103.       (setf czr (- czr))
  104.       (setf czi (- czi))
  105.      label70
  106.       (setf aphi (zabs phir phii))
  107.       (setf rcz czr)
  108.       (if (> rcz elim) (go label210))
  109.       (if (< rcz alim) (go label80))
  110.       (setf rcz (+ rcz (f2cl-lib:flog aphi)))
  111.       (if (= iform 2) (setf rcz (- rcz (* 0.25 (f2cl-lib:flog aarg)) aic)))
  112.       (if (> rcz elim) (go label210))
  113.       (go label130)
  114.      label80
  115.       (if (< rcz (- elim)) (go label90))
  116.       (if (> rcz (- alim)) (go label130))
  117.       (setf rcz (+ rcz (f2cl-lib:flog aphi)))
  118.       (if (= iform 2) (setf rcz (- rcz (* 0.25 (f2cl-lib:flog aarg)) aic)))
  119.       (if (> rcz (- elim)) (go label110))
  120.      label90
  121.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  122.                     ((> i nn) nil)
  123.         (tagbody
  124.           (f2cl-lib:fset (f2cl-lib:fref yr (i) ((1 n))) zeror)
  125.           (f2cl-lib:fset (f2cl-lib:fref yi (i) ((1 n))) zeroi)
  126.          label100))
  127.       (setf nuf nn)
  128.       (go end_label)
  129.      label110
  130.       (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
  131.       (multiple-value-bind
  132.           (var-0 var-1 var-2 var-3 var-4)
  133.           (zlog phir phii str sti idum)
  134.         (declare (ignore var-0 var-1))
  135.         (setf str var-2)
  136.         (setf sti var-3)
  137.         (setf idum var-4))
  138.       (setf czr (+ czr str))
  139.       (setf czi (+ czi sti))
  140.       (if (= iform 1) (go label120))
  141.       (multiple-value-bind
  142.           (var-0 var-1 var-2 var-3 var-4)
  143.           (zlog argr argi str sti idum)
  144.         (declare (ignore var-0 var-1))
  145.         (setf str var-2)
  146.         (setf sti var-3)
  147.         (setf idum var-4))
  148.       (setf czr (- czr (* 0.25 str) aic))
  149.       (setf czi (- czi (* 0.25 sti)))
  150.      label120
  151.       (setf ax (/ (exp rcz) tol))
  152.       (setf ay czi)
  153.       (setf czr (* ax (cos ay)))
  154.       (setf czi (* ax (sin ay)))
  155.       (multiple-value-bind
  156.           (var-0 var-1 var-2 var-3 var-4)
  157.           (zuchk czr czi nw ascle tol)
  158.         (declare (ignore var-0 var-1 var-3 var-4))
  159.         (setf nw var-2))
  160.       (if (/= nw 0) (go label90))
  161.      label130
  162.       (if (= ikflg 2) (go end_label))
  163.       (if (= n 1) (go end_label))
  164.      label140
  165.       (setf gnu (+ fnu (f2cl-lib:int-sub nn 1)))
  166.       (if (= iform 2) (go label150))
  167.       (setf init 0)
  168.       (multiple-value-bind
  169.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  170.            var-11 var-12 var-13 var-14 var-15 var-16)
  171.           (zunik zrr zri gnu ikflg 1 tol init phir phii zeta1r zeta1i zeta2r
  172.            zeta2i sumr sumi cwrkr cwrki)
  173.         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
  174.         (setf init var-6)
  175.         (setf phir var-7)
  176.         (setf phii var-8)
  177.         (setf zeta1r var-9)
  178.         (setf zeta1i var-10)
  179.         (setf zeta2r var-11)
  180.         (setf zeta2i var-12)
  181.         (setf sumr var-13)
  182.         (setf sumi var-14))
  183.       (setf czr (- zeta2r zeta1r))
  184.       (setf czi (- zeta2i zeta1i))
  185.       (go label160)
  186.      label150
  187.       (multiple-value-bind
  188.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  189.            var-11 var-12 var-13 var-14 var-15 var-16)
  190.           (zunhj znr zni gnu 1 tol phir phii argr argi zeta1r zeta1i zeta2r
  191.            zeta2i asumr asumi bsumr bsumi)
  192.         (declare (ignore var-0 var-1 var-2 var-3 var-4))
  193.         (setf phir var-5)
  194.         (setf phii var-6)
  195.         (setf argr var-7)
  196.         (setf argi var-8)
  197.         (setf zeta1r var-9)
  198.         (setf zeta1i var-10)
  199.         (setf zeta2r var-11)
  200.         (setf zeta2i var-12)
  201.         (setf asumr var-13)
  202.         (setf asumi var-14)
  203.         (setf bsumr var-15)
  204.         (setf bsumi var-16))
  205.       (setf czr (- zeta2r zeta1r))
  206.       (setf czi (- zeta2i zeta1i))
  207.       (setf aarg (zabs argr argi))
  208.      label160
  209.       (if (= kode 1) (go label170))
  210.       (setf czr (- czr zbr))
  211.       (setf czi (- czi zbi))
  212.      label170
  213.       (setf aphi (zabs phir phii))
  214.       (setf rcz czr)
  215.       (if (< rcz (- elim)) (go label180))
  216.       (if (> rcz (- alim)) (go end_label))
  217.       (setf rcz (+ rcz (f2cl-lib:flog aphi)))
  218.       (if (= iform 2) (setf rcz (- rcz (* 0.25 (f2cl-lib:flog aarg)) aic)))
  219.       (if (> rcz (- elim)) (go label190))
  220.      label180
  221.       (f2cl-lib:fset (f2cl-lib:fref yr (nn) ((1 n))) zeror)
  222.       (f2cl-lib:fset (f2cl-lib:fref yi (nn) ((1 n))) zeroi)
  223.       (setf nn (f2cl-lib:int-sub nn 1))
  224.       (setf nuf (f2cl-lib:int-add nuf 1))
  225.       (if (= nn 0) (go end_label))
  226.       (go label140)
  227.      label190
  228.       (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
  229.       (multiple-value-bind
  230.           (var-0 var-1 var-2 var-3 var-4)
  231.           (zlog phir phii str sti idum)
  232.         (declare (ignore var-0 var-1))
  233.         (setf str var-2)
  234.         (setf sti var-3)
  235.         (setf idum var-4))
  236.       (setf czr (+ czr str))
  237.       (setf czi (+ czi sti))
  238.       (if (= iform 1) (go label200))
  239.       (multiple-value-bind
  240.           (var-0 var-1 var-2 var-3 var-4)
  241.           (zlog argr argi str sti idum)
  242.         (declare (ignore var-0 var-1))
  243.         (setf str var-2)
  244.         (setf sti var-3)
  245.         (setf idum var-4))
  246.       (setf czr (- czr (* 0.25 str) aic))
  247.       (setf czi (- czi (* 0.25 sti)))
  248.      label200
  249.       (setf ax (/ (exp rcz) tol))
  250.       (setf ay czi)
  251.       (setf czr (* ax (cos ay)))
  252.       (setf czi (* ax (sin ay)))
  253.       (multiple-value-bind
  254.           (var-0 var-1 var-2 var-3 var-4)
  255.           (zuchk czr czi nw ascle tol)
  256.         (declare (ignore var-0 var-1 var-3 var-4))
  257.         (setf nw var-2))
  258.       (if (/= nw 0) (go label180))
  259.       (go end_label)
  260.      label210
  261.       (setf nuf -1)
  262.       (go end_label)
  263.      end_label
  264.       (return (values nil nil nil nil nil nil nil nil nuf nil nil nil)))))
  265.  
  266.